\ This module implements a number of words that we need only at compile time,
\ or only in the Mops development environment.

\ CASE[ is another keyed CASE.  Each test value or range is compiled into
\ a pair of 2-byte entries in a table.  Compilation is turned off and on
\ while getting the test values, which are evaluated at compile time.
\ This is slightly less flexible than Eaker's CASE, but is faster and more
\ compact.  It is also adequate for the majority of keyed case needs.  When
\ you want a positional case, SELECT{ is still the best.


false	value	NEED_EXIT?

: CASE[	immediate	\ ( -- mark chk cnt )  Implements CASE[ in main dic.
	postpone (case)
	here  0 ,				\ Table offset and end offset will go here
	11 ( chk value )  0  ( Initial case count )
	false -> need_exit?			\ No stub compiled yet
	postpone [  ;

: NEW_STUB  { chk cnt lo hi flg -- lo hi here chk cnt+1 }
	chk 11 ?pairs
	lo  hi  here
	need_exit?
	if  \ Compile (exit) for end of previous stub
		postpone (exit)
		2+				\ Adjust addr of new stub
	then
	flg -> need_exit?			\ True if we're starting a stub
	11  cnt 1+
	postpone ]  ;

: ]=>		immediate	dup  true new_stub   ;	
: ],		immediate	dup false new_stub   ;	
: RANGE]=>	immediate	true new_stub   ;	
: RANGE],		immediate	false new_stub   ;	

: DEFAULT=>   immediate   { chk cnt -- mark chk cnt }
	chk 11 ?pairs  cnt 0= abort" No cases!"
	postpone (exit)
	here 12 cnt  ;		immediate

: STUB>TBL  { lo hi mark -- }
	lo w,  hi w,  here mark -  w,  ;

: STUBS>TBL	\ ( cnt -- )
	for  stub>tbl  next  ;

: ]CASE	immediate   { dflt-mark chk cnt \ tbl-addr case-mrk -- }
	chk 12 ?pairs
	postpone (exit)  ( for default stub )
	here -> tbl-addr
    \ Now we build the table:
	cnt w,
	cnt stubs>tbl
	here  dflt-mark -  w,
	-> case-mrk		\ Addr following (CASE) - left in stk before
	tbl-addr case-mrk -  case-mrk w!
	here case-mrk -  case-mrk 2+ w!  ;

\		======== Code to aid testing =========

\ SM and BG set the Mops window small and big respectively.
\ SM is used when we want to split the screen for debugging.
\ It puts the Mops window in the lower half of the screen so the source
\ text window can occupy the top half.  BG puts the Mops window back to
\ where its normal size and position.

: SM	494 150 size: fwind  2 190 move: fwind  cls  ;
: BG	494 286 size: fwind  2  40 move: fwind  cls  ;


\		======== Display of source code ========

false	value	LOG_THERE?
false	value	SRC_THERE?
false	value	USE_MOD?

	objPtr	THEMOD  class_is module

	window	DW

	file	LOG
	file	SRC

	string+	DSP
	string+	S
	string+	$TMP
	string+	$LOG
	string+	$PRF

    0	value	CURS_POS
    0	value	CURS_ROW
    0	value	CURS_COL

    0	value	MK_CFA
    0	value	TOPDIR
    0	value	TOPDATE


: SET_DSP  { \ cr? -- }
	true -> cr?
	s  copyto: dsp
	curs_pos >pos: dsp
	2 0 DO  <nextline?: dsp  NIF  LEAVE  THEN  LOOP
	pos: dsp
	#lines 0 ?DO
		nextline?: dsp  NIF  false -> cr?  LEAVE  THEN
	LOOP
	>pos: dsp
	cr? more: dsp  ;


local DISPLAY  { disp? \ redraw? end_disp curs_line_pos 1st? -- }

: (DISP)
	0 -> curs_row  0 -> curs_line_pos  true -> 1st?
	disp? IF  4 tFont  9 tSize  -curs  cls  THEN		\ Monaco 9
	BEGIN
		nextline?: dsp  0EXIT
		lim: dsp  end_disp  > ?EXIT
		1st? IF  false -> 1st?  ELSE  disp? IF cr THEN  THEN
		lim: dsp  curs_pos  <
		IF  1 ++> curs_row  lim: dsp 1+  -> curs_line_pos  THEN
		disp? IF  get: dsp  type  THEN
	AGAIN  ;

: SHOW_CURS
	+curs  disp? NIF  .cur  THEN		\ If just updating, erase curs
	curs_pos curs_line_pos -  dup -> curs_col 1+  6 *	\ x
	curs_row 1+ #lead *  6 +				\ y
	gotoxy  .cur  ;

: (DISPLAY)
	lim: dsp  -> end_disp
	save: dsp  0 >len: dsp
	(disp)
	restore: dsp  ;


:loc DISPLAY
	set: dw
	(display)
	curs_row 0=  pos: dsp  0<>  and  -> redraw?
	curs_row 6 >  lim: dsp  size: dsp  <  and  --> redraw?
	redraw? IF  set_dsp  update: dw  THEN
	show_curs
	set: fWind  ;loc

' redraw  setdraw: dw		\ Note: this must refer to the EXPORTED
				\ version of redraw.

: REDRAW	true  display  ;
: UPD		false display  ;

: 1UP
	curs_pos 1-  0 max  dup >pos: s >lim: s
	<nextline?: s  0EXIT
	pos: s  dup IF  1+  THEN  -> curs_pos  upd  ;

: 1DN
	curs_pos dup >pos: s >lim: s
	nextline?: s  0EXIT
	lim: s 1+  -> curs_pos  upd  ;

: 1LFT	;	\ Really not much point in implementing these!
: 1RT   ;

: HOME		0	-> curs_pos  upd  ;
: END		size: s	-> curs_pos  upd  ;

: DEFNUP  { \ pos -- }
	curs_pos 1-  0 max  dup  >pos: s  >lim: s
	BEGIN
		<nextline?: s  0EXIT
		pos: s  -> pos  pos IF  1 ++> pos  THEN
		ptr: s  pos +  c@  & :  =
		IF  pos -> curs_pos  upd  EXIT  THEN
	AGAIN  ;

: DEFNDN
	curs_pos  dup  >pos: s  >lim: s
	BEGIN
		nextline?: s  0EXIT
		^1st: s  1+  c@  & :  =
		IF  pos: s  1+  -> curs_pos  upd  EXIT  THEN
	AGAIN  ;


: ADDR>CURS  { addr \ offs -- curs-pos }	\ Exported.
	log_there?  NIF  0  EXIT  THEN
	addr filestart_dp -  -> addr   0 -> offs
	reset: $log
	BEGIN
		len: $log  0<=  IF  0  EXIT  THEN
		^1st: $log  w@  addr >
		IF  ( found )
			offs -> curs_pos  upd   offs  EXIT
		THEN
		^1st: $log  2+  @  -> offs
		6 skip: $log
	AGAIN  ;


: SELECTDW			\ Exported.
	src_there?  0EXIT
	select: dw  ;


: OPEN_SRC_WINDOW
	sm
	new: s  s copyto: dsp  new: $tmp
	2 38  494 170  put: tempRect
	tempRect  " "
	docWind  true true  new: dw
\	10 10 500 300 true setDrag: dw
	screenbits true setGrow: dw
	select: fWind  set: fWind
	true -> src_there?  ;

: CHK_DATE
	getFileInfo: src  OK?  src 76 + @
	use_mod?
	IF
		base: theMod  @
	ELSE
		mk_cfa 6 + @  ?dup NIF -1 THEN
	THEN
	u>
	IF
		3 beep  cr  msg# 76	\ "Source later than compiled version"
	THEN  ;

	
: (OPEN_SRC)
	2dup  put: $tmp  2dup  name: src  title: dw
	use_mod?
	NIF
		mk_cfa @  setDirID: src
	THEN
	openReadOnly: src  ?EXIT  	\ Out on error
	chk_date
	src  readAll: s  close: src  drop
	0 -> curs_pos  set_dsp  update: dw  ;


: SRC_NAME
	mk_cfa >name n>count 1-  ;

: OPEN_SRC
	src_name  (open_src)  ;

: OPEN_SRC_IN_MOD
	txtName: theMod  (open_src)  ;


: (CREATE_LOG)
	here -> filestart_dp
	new: $lg1  new: $lg2
	$ B3010000 pad !	\ Unique marker for log files | version
	false -> relocChk?
	here pad 4+ reloc!
	true -> relocChk?
	pad 8  put: $lg1  ;


: (WRITE_LOG)		\ Called to write out the log and profile strings to the
			\  2 corresponding files
	getname: topfile  put: $tmp
	" .log"  add: $tmp
	all: $tmp  name: log
	use_mod?  IF  0  ELSE  topDir  THEN
	setDirID: log
		\ OK to use zero for modules, since the module's source
		\ file name will be fully qualified.
	create: log  ?dup
	IF  . space ." I/O err creating log file " abort  THEN
	0 setDirID: log
	'type SLOG  'type MOPS  set: log
	reset: $lg1  len: $lg1  ^1st: $lg1 2+  w!
	all: $lg1  write: log  OK?  all: $lg2  write: log  OK?
	close: log  OK?
	release: $lg1  release: $lg2  ;


: OPEN_LOG
	false -> log_there?
	clear: $log  clear: $prf
	use_mod?
	IF
		" .txt.log" extname: theMod  put: $tmp
		all: $tmp  name: log
\		base: theMod 4+ @  setDirID: log
	ELSE
		mk_cfa 4+  w@
		NIF  ( No log file )
			clear: $log  EXIT
		THEN
		" .log" add: $tmp
		all: $tmp  name: log  0 setVref: log
		mk_cfa @  setDirID: log
	THEN
	openReadOnly: log  ?EXIT		\ If error, maybe log not there.
	pad 8 read: log  OK?
	pad w@  $ B301 =  0EXIT		\ Out if not valid log file
	true -> log_there?
	use_mod?
	IF
		base: theMod
		#imp: theMod  2* +  8 +
	ELSE
		pad 4+ @abs
	THEN
	-> filestart_dp
	log  pad 2+ w@ 8 -  readN: $log
	log  readRest: $prf  close: log  drop
\	rd: $log  rd: $prf
\	set: fwind  dump: $log  set: dw		\ debugging only
	src_there? IF  redraw  THEN
	true -> log_there?  ;


: CL		\ Close src and log etc.
	src_there?  0EXIT
	close: dw  release: s  release: $tmp  release: $log  release: $prf
	close: src drop
	false -> log_there?  false -> src_there?
	drop: extrasmod  ;


: (FINDMK)	\ ( cfa 0 -- )
	drop  dup -> mk_cfa  2- w@x file-mark = -> endTrav?  ;
	
: FIND_MARK?	\ ( start-addr -- )
	['] (findmk)  0  rot  trav-from
	endTrav?  ;


: LOCATE_SRC	\ ( cfa -- )  Exported.  Opens source window for given
		\ definition, if possible.
	lock: extrasmod		\ Since we have a window, and windows
				\ mustn't move!
	use_mod?
	NIF
		find_mark?
		NIF
			src_there?  IF  cl  THEN  EXIT
		THEN
	ELSE
		drop
	THEN
	src_there?
	NIF  open_src_window  THEN
	use_mod?
	IF
		open_src_in_mod  open_log
		false -> use_mod?	\ For next time
	ELSE
		open_src  open_log
	THEN  ;


: USE_MODULE	\ ( ^mod -- )
	-> theMod  true -> use_mod?  ;

: PROF_STR	\ Exported - called by DebugMod to get hold of the profile
		\  string and source string.
	reset: $prf  reset: s
	$prf  s  ;


\	======== Code for loading and reloading =========

: PURGE_INIT_ACTIONS  { \ index -- }
			\ We call this before reloading, to get rid of any
			\ invalid entries out of INIT_ACTIONS.
	0 -> index
	BEGIN
		index  size: init_actions  >=  ?EXIT
		index  ^elem: init_actions  @abs  here u>
		IF	index  remove: init_actions
		ELSE	1 ++> index
		THEN
	AGAIN  ;


: <CS  { addr len c \ offs -- addr len offs }
	len -> offs
	addr  addr len + 1-  DO
		i c@  c = IF  LEAVE  THEN
		-1 ++> offs
	-1 +LOOP
	addr len offs  ;


: +LOG		true  -> log?  ;
: -LOG		false -> log?  ;


: SAVE-LOAD
	getName: topFile  put: $tmp  bl +: $tmp  reset: $tmp
	& :  <chsearch: $tmp  negate skip: $tmp
	get: $tmp  sHdr  file-mark w,
	topDir ,  log? w,  topDate ,
	release: $tmp  ;


: LOADIT  { \ svCurs -- }
	watchcurs  purge_init_actions
	curs -> svCurs -curs
	getFileInfo: topFile  NIF  topFile 76 + @  ELSE  0  THEN  -> topDate
	clear: topFile
	topDir  setDirID: topFile
	save-load
	MBcomp LdFromMod  drop: loadFile
\	log?  IF  -log  THEN
	svCurs -> curs
	arrowcurs  ;


: L         \ Load
	pushNew: loadfile
	'type TEXT 1 stdget: topfile
	IF
		getDirID  dup  setDirID: topFile  -> topDir
		loadit
	ELSE
		clear: loadfile
	THEN  ;  

: FM		\ Forget to mark
	here find_mark?  not abort" No mark!"
	mk_cfa >link (forget)  ;

: RL
	here find_mark?  not abort" L not done!"
	cl		\ Close source window if open as it probably
			\ won't be valid any more.
	pushnew: loadfile
	src_name  name: topFile
	mk_cfa @  dup  -> topDir  setDirID: topFile
\	mk_cfa 4+ w@x  ++> log?
	mk_cfa >link (forget)  loadit  ;



\ Put NEED XXX at the start of a file that requires XXX to be already
\ loaded.  If the word XXX is not defined, a file of that name is loaded.
\ Note that only one blank or tab is allowed between NEED and the ilename.
\ This is because we use WORD" to read the ilename, so that names with
\ embedded blanks are allowed.

: NEED  { \ svLog svTopDir svTopDate -- }
	word"  count				\ Get name from input
	put: $tmp  bl +: $tmp  reset: $tmp
	& :  <chsearch: $tmp  negate skip: $tmp
	get: $tmp  sFind  nip
	IF  release: $tmp  EXIT  THEN	\ Found - nothing else to do
						\ Not found - load it
	latest name> 2- w@x  file-mark =
	IF				\ That was a file-mark - forget it so RL
					\  won't make us reload NEEDed files
		latest n>link (forget)
	THEN
	pushnew: loadFile  get: $tmp  1-  name: topfile
	release: $tmp
	log? -> svLog
	-log					\ Don't log NEEDed file
	openReadOnly: topFile  OK?
	close: topFile  drop
	getFileInfo: topFile  OK?
	topDate -> svTopDate
	topDir -> svTopDir
\	getDirID: topFile  -> topDir	  \ I'm not too sure why this doesn't work
	0 -> topDir
	clear: topFile				\ Leaves name field intact
	loadit					\ Load NEEDed file
	svLog IF  +log  THEN
	svTopDate -> topDate
	svTopDir  -> topDir
	save-load  ;

' cl  setrelease